home *** CD-ROM | disk | FTP | other *** search
- ;; ========================================================================
- ;; lib-complete.el -- Completion on a search path
- ;; Author : Mike Williams <mike-w@cs.aukuni.ac.nz>
- ;; Created On : Sat Apr 20 17:47:21 1991
- ;; Last Modified By: Heiko M|nkel <muenkel@tnt.uni-hannover.de>
- ;; Last Modified On: Thu Jul 1 14:23:00 1994
- ;; RCS Info : $Revision: 1.7.1 $ $Locker: $
- ;; ========================================================================
- ;; NOTE: this file must be recompiled if changed.
- ;;
- ;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991
- ;;
- ;; Keywords: utility, lisp
-
- ;; This file is part of XEmacs.
-
- ;; XEmacs is free software; you can redistribute it and/or modify it
- ;; under the terms of the GNU General Public License as published by
- ;; the Free Software Foundation; either version 2, or (at your option)
- ;; any later version.
-
- ;; XEmacs is distributed in the hope that it will be useful, but
- ;; WITHOUT ANY WARRANTY; without even the implied warranty of
- ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- ;; General Public License for more details.
-
- ;; You should have received a copy of the GNU General Public License
- ;; along with XEmacs; see the file COPYING. If not, write to the Free
- ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ;;; Synched up with: Not part of FSF.
-
- ;; Many thanks to Hallvard Furuseth <hallvard@ifi.uio.no> for his
- ;; helpful suggestions.
-
- ;; The function locate-file is removed, because of its incompatibility
- ;; with the buildin function of the lemacs 19.10 (Heiko M|nkel).
-
- ;; There is now the new function find-library in this package.
-
- (provide 'lib-complete)
-
- ;;=== Usage ===============================================================
- ;;
- ;; (autoload (fmakunbound 'load-library) "lib-complete" nil t)
- ;; (autoload 'library-all-completions "lib-complete")
- ;; (autoload 'read-library "lib-complete")
- ;; (autoload 'find-library "lib-complete"
- ;; "Find and edit the source for the library named LIBRARY.
- ;; The extension of the LIBRARY must be omitted.")
-
- ;;=== Locate a file in a search path ======================================
-
- ;(defun locate-file (FILE SEARCH-PATH &optional SUFFIX-LIST PRED)
- ; "Search for FILE on SEARCH-PATH (list). If optional SUFFIX-LIST is
- ;provided, allow file to be followed by one of the suffixes.
- ;Optional second argument PRED restricts the number of files which
- ;may match. The default is file-exists-p."
- ; (if (not SUFFIX-LIST) (setq SUFFIX-LIST '("")))
- ; (if (not PRED) (setq PRED 'file-exists-p))
- ; (if (file-name-absolute-p FILE) (setq SEARCH-PATH '(nil)))
- ; (if (equal FILE "") (error "Empty filename"))
- ; (let ((filelist
- ; (mapcar
- ; (function (lambda (ext) (concat FILE ext)))
- ; SUFFIX-LIST)))
- ; ;; Search SEARCH-PATH for a readable file in filelist
- ; (catch 'found
- ; (while SEARCH-PATH
- ; (let ((filelist filelist))
- ; (while filelist
- ; (let ((filepath (expand-file-name (car filelist)
- ; (car SEARCH-PATH))))
- ; (if (funcall PRED filepath)
- ; (throw 'found filepath)))
- ; (setq filelist (cdr filelist))))
- ; (setq SEARCH-PATH (cdr SEARCH-PATH))))
- ; ))
-
- ;;=== Determine completions for filename in search path ===================
-
- (defun library-all-completions (FILE SEARCH-PATH &optional FULL FAST)
- "Return all completions for FILE in any directory on SEARCH-PATH.
- If optional third argument FULL is non-nil, returned pathnames should be
- absolute rather than relative to some directory on the SEARCH-PATH.
- If optional fourth argument FAST is non-nil, don't sort the completions,
- or remove duplicates."
- (setq FILE (or FILE ""))
- (if (file-name-absolute-p FILE)
- ;; It's an absolute file name, so don't need SEARCH-PATH
- (progn
- (setq FILE (expand-file-name FILE))
- (file-name-all-completions
- (file-name-nondirectory FILE) (file-name-directory FILE)))
- (let ((subdir (file-name-directory FILE))
- (file (file-name-nondirectory FILE))
- all-completions)
- ;; Make list of completions in each directory on SEARCH-PATH
- (while SEARCH-PATH
- (let* ((dir (concat (file-name-as-directory
- (expand-file-name (car SEARCH-PATH)))
- subdir))
- (dir-prefix (if FULL dir subdir)))
- (if (file-directory-p dir)
- (let ((subdir-completions
- (file-name-all-completions file dir)))
- (while subdir-completions
- (setq all-completions
- (cons (concat dir-prefix (car subdir-completions))
- all-completions))
- (setq subdir-completions (cdr subdir-completions))))))
- (setq SEARCH-PATH (cdr SEARCH-PATH)))
- (if FAST all-completions
- (let ((sorted (nreverse (sort all-completions 'string<)))
- compressed)
- (while sorted
- (if (equal (car sorted) (car compressed)) nil
- (setq compressed (cons (car sorted) compressed)))
- (setq sorted (cdr sorted)))
- compressed)))))
-
- ;;=== Utilities ===========================================================
-
- (defmacro progn-with-message (MESSAGE &rest FORMS)
- "(progn-with-message MESSAGE FORMS ...)
- Display MESSAGE and evaluate FORMS, returning value of the last one."
- ;; based on Hallvard Furuseth's funcall-with-message
- (`
- (if (eq (selected-window) (minibuffer-window))
- (save-excursion
- (goto-char (point-max))
- (let ((orig-pmax (point-max)))
- (unwind-protect
- (progn
- (insert " " (, MESSAGE)) (goto-char orig-pmax)
- (sit-for 0) ; Redisplay
- (,@ FORMS))
- (delete-region orig-pmax (point-max)))))
- (prog2
- (message "%s" (, MESSAGE))
- (progn (,@ FORMS))
- (message "")))))
-
- (put 'progn-with-message 'lisp-indent-hook 1)
-
- ;;=== Completion caching ==================================================
-
- (defconst lib-complete:cache nil
- "Used within read-library and read-library-internal to prevent
- costly repeated calls to library-all-completions.
- Format is a list of lists of the form
-
- ([<path> <subdir>] <cache-record> <cache-record> ...)
-
- where each <cache-record> has the form
-
- (<root> <modtimes> <completion-table>)")
-
- (defun lib-complete:better-root (ROOT1 ROOT2)
- "Return non-nil if ROOT1 is a superset of ROOT2."
- (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2))
- (string-match
- (concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
- ROOT2)))
-
- (defun lib-complete:get-completion-table (FILE PATH FILTER)
- (let* ((subdir (file-name-directory FILE))
- (root (file-name-nondirectory FILE))
- (PATH
- (mapcar
- (function (lambda (dir) (file-name-as-directory
- (expand-file-name (or dir "")))))
- PATH))
- (key (vector PATH subdir FILTER))
- (real-dirs
- (if subdir
- (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
- PATH))
- (path-modtimes
- (mapcar
- (function (lambda (fn) (if fn (nth 5 (file-attributes fn)))))
- real-dirs))
- (cache-entry (assoc key lib-complete:cache))
- (cache-records (cdr cache-entry)))
- ;; Look for cached entry
- (catch 'table
- (while cache-records
- (if (and
- (lib-complete:better-root (nth 0 (car cache-records)) root)
- (equal (nth 1 (car cache-records)) path-modtimes))
- (throw 'table (nth 2 (car cache-records))))
- (setq cache-records (cdr cache-records)))
- ;; Otherwise build completions
- (let ((completion-list
- (progn-with-message "(building completion table...)"
- (library-all-completions FILE PATH nil 'fast)))
- (completion-table (make-vector 127 0)))
- (while completion-list
- (let ((completion
- (if (or (not FILTER)
- (file-directory-p (car completion-list)))
- (car completion-list)
- (funcall FILTER (car completion-list)))))
- (if completion
- (intern completion completion-table)))
- (setq completion-list (cdr completion-list)))
- ;; Cache the completions
- (lib-complete:cache-completions key root
- path-modtimes completion-table)
- completion-table))))
-
- (defvar lib-complete:max-cache-size 20
- "*Maximum number of search paths which are cached.")
-
- (defun lib-complete:cache-completions (KEY ROOT MODTIMES TABLE)
- (let ((cache-entry (assoc key lib-complete:cache))
- (cache-records (cdr cache-entry))
- (new-cache-records (list (list ROOT MODTIMES TABLE))))
- (if (not cache-entry) nil
- ;; Remove old cache entry
- (setq lib-complete:cache (delq cache-entry lib-complete:cache))
- ;; Copy non-redundant entries from old cache entry
- (while cache-records
- (if (or (equal ROOT (nth 0 (car cache-records)))
- (lib-complete:better-root ROOT (nth 0 (car cache-records))))
- nil
- (setq new-cache-records
- (cons (car cache-records) new-cache-records)))
- (setq cache-records (cdr cache-records))))
- ;; Add entry to front of cache
- (setq lib-complete:cache
- (cons (cons KEY (nreverse new-cache-records)) lib-complete:cache))
- ;; Trim cache
- (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
- (if tail (setcdr tail nil)))))
-
- ;;=== Read a filename, with completion in a search path ===================
-
- (defun read-library-internal (FILE FILTER FLAG)
- "Don't call this."
- ;; Relies on read-library-internal-search-path being let-bound
- (let ((completion-table
- (lib-complete:get-completion-table
- FILE read-library-internal-search-path FILTER)))
- (cond
- ((not completion-table) nil)
- ;; Completion table is filtered before use, so the PREDICATE
- ;; argument is redundant.
- ((eq FLAG nil) (try-completion FILE completion-table nil))
- ((eq FLAG t) (all-completions FILE completion-table nil))
- ((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t))
- )))
-
- (defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH
- FULL FILTER)
- "Read library name, prompting with PROMPT and completing in directories
- from SEARCH-PATH. A nil in the search path represents the current
- directory. Completions for a given search-path are cached, with the
- cache being invalidated whenever one of the directories on the path changes.
- Default to DEFAULT if user enters a null string.
- Optional fourth arg MUST-MATCH non-nil means require existing file's name.
- Non-nil and non-t means also require confirmation after completion.
- Optional fifth argument FULL non-nil causes a full pathname, rather than a
- relative pathname, to be returned. Note that FULL implies MUST-MATCH.
- Optional sixth argument FILTER can be used to provide a function to
- filter the completions. This function is passed the filename, and should
- return a transformed filename (possibly a null transformation) or nil,
- indicating that the filename should not be included in the completions."
- (let* ((read-library-internal-search-path SEARCH-PATH)
- (library (completing-read PROMPT 'read-library-internal
- FILTER (or MUST-MATCH FULL) nil)))
- (cond
- ((equal library "") DEFAULT)
- (FULL (locate-file library read-library-internal-search-path ".el:.elc"))
- (t library))))
-
- ;; NOTE: as a special case, read-library may be used to read a filename
- ;; relative to the current directory, returning a *relative* pathname
- ;; (read-file-name returns a full pathname).
- ;;
- ;; eg. (read-library "Local header: " '(nil) nil)
-
- (defun get-library-path ()
- "Front end to read-library"
- (read-library "Find Library file: " load-path nil t t
- (function (lambda (fn)
- (cond
- ((string-match "\\.el$" fn)
- (substring fn 0 (match-beginning 0))))))
- ))
-
- ;;=== Replacement for load-library with completion ========================
-
- (defun load-library (LIBRARY)
- "Load the library named LIBRARY."
- (interactive
- (list (read-library "Load Library: " load-path nil nil nil
- (function (lambda (fn)
- (cond
- ((string-match "\\.elc?$" fn)
- (substring fn 0 (match-beginning 0))))))
- )))
- (load LIBRARY))
-
- ;;=== find-library with completion (Author: Heiko Muenkel) ===================
-
- (defun find-library (library)
- "Find and edit the source for the library named LIBRARY.
- The extension of the LIBRARY must be omitted."
- (interactive
- (list
- (get-library-path)))
- (find-file library))
-
- (defun find-library-other-window (library)
- "Load the library named LIBRARY."
- (interactive
- (list (get-library-path)))
- (find-file-other-window library))
-
- (defun find-library-other-screen (library)
- "Load the library named LIBRARY."
- (interactive
- (list (get-library-path)))
- (find-file-other-screen library))
-
- (define-key global-map "\C-xl" 'find-library)
- (define-key global-map "\C-x4l" 'find-library-other-window)
- (define-key global-map "\C-x5l" 'find-library-other-screen)
-
-